home *** CD-ROM | disk | FTP | other *** search
/ Aminet 28 / Aminet 28 (1998)(GTI - Schatztruhe)[!][Dec 1998].iso / Aminet / dev / lang / fpcsrc.lha / fpc / compiler / psub.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  56KB  |  1,526 lines
  1. {
  2.     $Id: psub.pas,v 1.3.2.4 1998/08/22 10:23:00 florian Exp $
  3.     Copyright (c) 1998 by Florian Klaempfl, Daniel Mantoine
  4.  
  5.     Does the parsing of the procedures/functions
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit psub;
  24. interface
  25.  
  26. uses cobjects;
  27.  
  28. procedure compile_proc_body(const proc_names:Tstringcontainer;
  29.                             make_global,parent_has_class:boolean);
  30. procedure _proc_head(options : word);
  31. procedure proc_head;
  32. procedure unter_dec;
  33.  
  34.  
  35. implementation
  36.  
  37. uses
  38.   globals,scanner,symtable,aasm,tree,pass_1,
  39.   types,hcodegen,files,verbose,systems,strings,link,import
  40. {$ifdef GDB}
  41.   ,gdb
  42. {$endif GDB}
  43.   { parser specific stuff }
  44.   ,pbase,ptconst,pdecl,pexpr,pstatmnt
  45.   { processor specific stuff }
  46. {$ifdef i386}
  47.   ,i386,cgai386,tgeni386,cgi386,aopt386
  48. {$endif}
  49. {$ifdef m68k}
  50.   ,m68k,cga68k,tgen68k,cg68k
  51. {$endif}
  52.   ;
  53.  
  54. procedure formal_parameter_list;
  55.  
  56. { handle_procvar needs the same changes }
  57.  
  58. var sc:Pstringcontainer;
  59.     s:string;
  60.     p:Pdef;
  61.     vs:Pvarsym;
  62.     hs1,hs2:string;
  63.     varspez:Tvarspez;
  64.  
  65. begin
  66.     consume(LKLAMMER);
  67.     inc(testcurobject);
  68.     repeat
  69.         if token=_VAR then
  70.             begin
  71.                 consume(_VAR);
  72.                 varspez:=vs_var;
  73.             end
  74.         else
  75.             if token=_CONST then
  76.                 begin
  77.                     consume(_CONST);
  78.                     varspez:=vs_const;
  79.                 end
  80.             else
  81.                 varspez:=vs_value;
  82.         sc:=idlist;
  83.         if token=COLON then
  84.             begin
  85.                 consume(COLON);
  86.                 { check for an open array }
  87.                 if token=_ARRAY then
  88.                     begin
  89.                         if (varspez<>vs_const) and (varspez<>vs_var) then
  90.                             begin
  91.                                 varspez:=vs_const;
  92.                                 Message(parser_e_illegal_open_parameter);
  93.                             end;
  94.                         consume(_ARRAY);
  95.                         consume(_OF);
  96.                         { define range and type of range }
  97.                         p:=new(Parraydef,init(0,-1,s32bitdef));
  98.                         { define field type }
  99.                         Parraydef(p)^.definition:=single_type(hs1);
  100.                         hs1:='array_of_'+hs1;
  101.                     end
  102.                 else
  103.                     p:=single_type(hs1);
  104.             end
  105.         else
  106.             begin
  107. {$ifndef UseNiceNames}
  108.                 hs1:='$$$';
  109. {$else UseNiceNames}
  110.                 hs1:='var';
  111. {$endif UseNiceNames}
  112.                 p:=new(Pformaldef,init);
  113.             end;
  114.         s:=sc^.get;
  115.         hs2:=aktprocsym^.definition^.mangledname;
  116.         while s<>'' do
  117.             begin
  118.                 aktprocsym^.definition^.concatdef(p,varspez);
  119. {$ifndef UseNiceNames}
  120.                 hs2:=hs2+'$'+hs1;
  121. {$else UseNiceNames}
  122.                 hs2:=hs2+tostr(length(hs1))+hs1;
  123. {$endif UseNiceNames}
  124.                 vs:=new(Pvarsym,init(s,p));
  125.                 vs^.varspez:=varspez;
  126.                 { we have to add this
  127.                   to avoid var param to be in registers !!!}
  128.                 if (varspez=vs_var) or (varspez=vs_const) and
  129.                  dont_copy_const_param(p) then
  130.                     vs^.regable:=false;
  131.                 aktprocsym^.definition^.parast^.insert(vs);
  132.                 s:=sc^.get;
  133.             end;
  134.         dispose(sc,done);
  135.         aktprocsym^.definition^.setmangledname(hs2);
  136.         if token=SEMICOLON then
  137.             consume(SEMICOLON)
  138.         else
  139.             break;
  140.     until false;
  141.     dec(testcurobject);
  142.     consume(RKLAMMER);
  143. end;
  144.  
  145. { contains the real name of a procedure as it's typed }
  146. { (the pattern isn't upper cased)                     }
  147.  
  148. var realname:stringid;
  149.  
  150. procedure _proc_head(options : word);
  151.  
  152. var sp:stringid;
  153.     pd:Pprocdef;
  154.     paramoffset:longint;
  155.     hsymtab:Psymtable;
  156.     sym:Psym;
  157.     hs:string;
  158.     overloaded_level:word;
  159.  
  160. begin
  161.     if (options and pooperator) <> 0 then
  162.         begin
  163.             sp:=overloaded_names[optoken];
  164.             realname:=sp;
  165.         end
  166.     else
  167.         begin
  168.             sp:=pattern;
  169.             realname:=orgpattern;
  170.             consume(ID);
  171.         end;
  172.  
  173.     { method ? }
  174.     if (token=POINT) and not(parse_only) then
  175.         begin
  176.             consume(POINT);
  177.             getsym(sp,true);
  178.             sym:=srsym;
  179.             { qualifier is class name ? }
  180.             if (sym^.typ<>typesym) or
  181.              (ptypesym(sym)^.definition^.deftype<>objectdef) then
  182.                Message(parser_e_class_id_expected);
  183.             { used to allow private syms to be seen }
  184.             aktobjectdef:=pobjectdef(ptypesym(sym)^.definition);
  185.             sp:=pattern;
  186.             realname:=orgpattern;
  187.             consume(ID);
  188.             procinfo._class:=pobjectdef(ptypesym(sym)^.definition);
  189.             aktprocsym:=pprocsym(procinfo._class^.publicsyms^.search(sp));
  190.             aktobjectdef:=nil;
  191.             { we solve this below }
  192.             if not(assigned(aktprocsym)) then
  193.              Message(parser_e_methode_id_expected);
  194.         end
  195.     else
  196.         begin
  197.             if not(parse_only) and
  198.              ((options and (poconstructor or podestructor))<>0) then
  199.                 Message(parser_e_constructors_always_objects);
  200.  
  201.             aktprocsym:=pprocsym(symtablestack^.search(sp));
  202.             if lexlevel=1 then
  203. {$ifdef UseNiceNames}
  204.                 hs:=procprefix+'_'+tostr(length(sp))+sp
  205. {$else UseNiceNames}
  206.                 hs:=procprefix+'_'+sp
  207. {$endif UseNiceNames}
  208.             else
  209. {$ifdef UseNiceNames}
  210.                 hs:=lowercase(procprefix)+'_'+tostr(length(sp))+sp;
  211. {$else UseNiceNames}
  212.                 hs:=procprefix+'_$'+sp;
  213. {$endif UseNiceNames}
  214.             if not(parse_only) then
  215.                 begin
  216.                     {The procedure we prepare for is in the implementation
  217.                      part of the unit we compile. It is also possible that we
  218.                      are compiling a program, which is also some kind of
  219.                      implementaion part.
  220.  
  221.                      We need to find out if the procedure is global. If it is
  222.                      global, it is in the global symtable.}
  223.                     if not assigned(aktprocsym) then
  224.                         begin
  225.                             {Search the procedure in the global symtable.}
  226.                             aktprocsym:=Pprocsym(search_a_symtable(sp,
  227.                              globalsymtable));
  228.  
  229.                             if assigned(aktprocsym) then
  230.                                 begin
  231.                                     {Check if it is a procedure.}
  232.                                     if typeof(aktprocsym^)<>typeof(Tprocsym) then
  233.                                      Message1(sym_e_duplicate_id,aktprocsym^.Name);
  234.  
  235.                                     {The procedure has been found. So it is
  236.                                      a global one. Set the flags to mark
  237.                                      this.}
  238.                                     procinfo.flags:=procinfo.flags or
  239.                                      pi_is_global;
  240.                                 end;
  241.                         end;
  242.                 end;
  243.         end;
  244.     { problem with procedures inside methods }
  245. {$ifndef UseNiceNames}
  246.     if assigned(procinfo._class) and (pos('_$$_',procprefix)=0) then
  247.         hs:=procprefix+'_$$_'+procinfo._class^.name^+'_'+sp;
  248. {$else UseNiceNames}
  249.     if assigned(procinfo._class) and (pos('_5Class_',procprefix)=0) then
  250.